home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / seqprocs.ss < prev    next >
Text File  |  1993-11-07  |  7KB  |  266 lines
  1. ;seqprocs.ss
  2. ;SLaTeX Version 1.99
  3. ;Sequence routines
  4. ;(c) Dorai Sitaram, December 1991, Rice University
  5.  
  6. '(enable schemetoc)
  7. (define list? 
  8.   (lambda (x)
  9.     ;tests if x is a proper list;
  10.     ;rnrs but not in scheme-to-c
  11.     (if (pair? x) (list? (cdr x)) (null? x))))
  12.  
  13. '(enable cl)
  14. (define ormap some)
  15.  
  16. '(enable cscheme)
  17. (define ormap (lambda (f l) (there-exists? l f)))
  18.  
  19. '(disable chez cl cscheme)
  20. (define ormap
  21.   (lambda (f l)
  22.     ;returns nonfalse iff f is true of at least one element in l;
  23.     ;this nonfalse value is that given by the first such element in l;
  24.     ;only one argument list supported
  25.     (let loop ((l l))
  26.       (if (null? l) #f
  27.     (or (f (car l)) (loop (cdr l)))))))
  28.  
  29. (define ormapcdr 
  30.   (lambda (f l)
  31.     ;returns the first cdr of l for which f is true;
  32.     ;only one argument list supported
  33.     (let loop ((l l))
  34.       (if (null? l) #f
  35.     (or (f l) (loop (cdr l)))))))
  36.  
  37. '(enable cl)
  38. (define append! nconc)
  39.  
  40. '(disable chez cl cscheme elk scmj)
  41. (define append!
  42.   (lambda (l1 l2)
  43.     ;destructively appends lists l1 and l2;
  44.     ;only two argument lists supported
  45.     (cond ((null? l1) l2)
  46.       ((null? l2) l1)
  47.       (else (let loop ((l1 l1))
  48.           (if (null? (cdr l1))
  49.               (set-cdr! l1 l2)
  50.               (loop (cdr l1))))
  51.         l1))))
  52.  
  53. '(enable cl)
  54. (define append-map! mapcan)
  55.  
  56. '(disable cl cscheme)
  57. (define append-map!
  58.   (lambda (f l)
  59.     ;maps f on l but splices (destructively) the results;
  60.     ;only one argument list supported
  61.     (let loop ((l l))
  62.       (if (null? l) '()
  63.     (append! (f (car l)) (loop (cdr l)))))))
  64.  
  65. '(enable cl)
  66. (define rem! delete-if)
  67.  
  68. '(disable chez cl)
  69. (define rem!
  70.   (lambda (? s)
  71.     ;returns those elements of list s for which pred ? holds;
  72.     ;s may be side-effected;
  73.     (let ((headed-s (cons 'void s)))
  74.       (let loop ((s s) (trail headed-s))
  75.     (if (null? s) (cdr headed-s)
  76.       (let ((a (car s)))
  77.         (if (? a)
  78.         (let ((d (cdr s)))
  79.           (set-cdr! trail d)
  80.           (loop d trail))
  81.         (loop (cdr s) s))))))))
  82.  
  83. '(enable cl)
  84. (define reverse! nreverse)
  85.  
  86. '(disable chez cl cscheme elk)
  87. (define reverse!
  88.   (lambda (s)
  89.     ;reverses list s inplace (i.e., destructively)
  90.     (let loop ((s s) (r '()))
  91.       (if (null? s) r
  92.     (let ((d (cdr s)))
  93.       (set-cdr! s r)
  94.       (loop d s))))))
  95.  
  96. '(enable cl)
  97. (define list-set! sequence-set!)
  98.  
  99. '(disable cl)
  100. (define list-set!
  101.   (lambda (l i v)
  102.     ;sets the i-th element of list l to v
  103.     (let loop ((l l) (i i))
  104.       (cond ((null? l) (lerror "list-set!: list too small"))
  105.         ((= i 0) (set-car! l v))
  106.         (else (loop (cdr l) (- i 1)))))))
  107.  
  108. (define list-prefix?
  109.   (lambda (pfx l)
  110.     ;tests if list pfx is a prefix of list l
  111.     (cond ((null? pfx) #t)
  112.       ((null? l) #f)
  113.       ((eqv? (car pfx) (car l)) (list-prefix? (cdr pfx) (cdr l)))
  114.       (else #f))))
  115.  
  116. (define string-prefix?
  117.   (lambda (pfx s)
  118.     ;tests if string pfx is a prefix of string s
  119.     (let ((pfx-len (string-length pfx)) (s-len (string-length s)))
  120.       (if (> pfx-len s-len) #f
  121.     (let loop ((i 0))
  122.       (if (>= i pfx-len) #t
  123.         (and (char=? (string-ref pfx i) (string-ref s i))
  124.          (loop (+ i 1)))))))))
  125.  
  126. (define string-suffix?
  127.   (lambda (sfx s)
  128.     ;tests if string sfx is a suffix of string s
  129.     (let ((sfx-len (string-length sfx)) (s-len (string-length s)))
  130.       (if (> sfx-len s-len) #f
  131.     (let loop ((i (- sfx-len 1)) (j (- s-len 1)))
  132.       (if (< i 0) #t
  133.         (and (char=? (string-ref sfx i) (string-ref s j))
  134.          (loop (- i 1) (- j 1)))))))))
  135.  
  136. (define member-string member)
  137.  
  138. '(enable cl)
  139. (define adjoin-string
  140.   (lambda (s l)
  141.     (adjoin s l :test string=?)))
  142.  
  143. '(disable cl)
  144. (define adjoin-string
  145.   (lambda (s l)
  146.     ;adjoins string s to string-set l
  147.     (if (member-string s l) l
  148.       (cons s l))))
  149.  
  150. '(enable cl)
  151. (define remove-string!
  152.   (lambda (s l)
  153.     (delete s l :test string=?)))
  154.  
  155. '(enable chez schemetoc)
  156. (define remove-string! remove!)
  157.  
  158. '(disable chez cl schemetoc)
  159. (define remove-string!
  160.   (lambda (s l)
  161.     ;destructively removes string s from string-set l
  162.     (rem! (lambda (l_i) (string=? l_i s)) l)))
  163.  
  164. '(enable cl)
  165. (define adjoin-char
  166.   (lambda (c l)
  167.     (adjoin c l :test char=?)))
  168.  
  169. '(disable cl)
  170. (define adjoin-char
  171.   (lambda (c l)
  172.     ;adjoins char c to a char-set l
  173.     (if (memv c l) l (cons c l))))
  174.  
  175. '(enable cl)
  176. (define remove-char!
  177.   (lambda (c l)
  178.     (delete c l :test char=?)))
  179.  
  180. '(enable chez schemetoc)
  181. (define remove-char! remv!)
  182.  
  183. '(disable chez cl schemetoc)
  184. (define remove-char!
  185.   (lambda (c l)
  186.     ;destructively removes char c from char-set l
  187.     (rem! (lambda (l_i) (char=? l_i c)) l)))
  188.  
  189. '(enable cl)
  190. (define sublist subseq)
  191.  
  192. '(disable cl)
  193. (define sublist
  194.   (lambda (l i f)
  195.     ;finds the sublist of l from index i inclusive to index f exclusive
  196.     (let loop ((l (list-tail l i)) (k i) (r '()))
  197.       (cond ((>= k f) (reverse! r))
  198.         ((null? l) (lerror 'sublist))
  199.         (else (loop (cdr l) (+ k 1) (cons (car l) r)))))))
  200.  
  201. '(enable cl)
  202. (define position-char position)
  203.  
  204. '(disable cl)
  205. (define position-char
  206.   (lambda (c l)
  207.     ;finds the leftmost index of character-list l where character c occurs
  208.     (let loop ((l l) (i 0))
  209.       (cond ((null? l) #f)
  210.         ((char=? (car l) c) i)
  211.         (else (loop (cdr l) (+ i 1)))))))
  212.  
  213. '(enable cl)
  214. (define string-position-right
  215.   (lambda (c s)
  216.     (position c s :test char=? :from-end #t)))   
  217.  
  218. '(disable cl)
  219. (define string-position-right
  220.   (lambda (c s)
  221.     ;finds the rightmost index of string s where character c occurs
  222.     (let ((n (string-length s)))
  223.       (let loop ((i (- n 1)))
  224.     (cond ((< i 0) #f)
  225.           ((char=? (string-ref s i) c) i)
  226.           (else (loop (- i 1))))))))
  227.  
  228. (define token=?
  229.   (lambda (t1 t2)
  230.     ;tests if t1 and t2 are identical tokens
  231.     ((if *slatex-case-sensitive?* string=? string-ci=?) t1 t2)))
  232.  
  233. '(enable cl)
  234. (define assoc-token
  235.   (lambda (x s)
  236.     (lisp:assoc x s :test token=?)))
  237.  
  238. '(disable cl)
  239. (define assoc-token
  240.   (lambda (x s)
  241.     ;finds cell corresponding to token x in alist s
  242.     (ormap (lambda (s_i) (if (token=? (car s_i) x) s_i #f)) s)))
  243.  
  244. '(enable cl)
  245. (define member-token
  246.   (lambda (x s)
  247.     (lisp:member x s :test token=?)))
  248.  
  249. '(disable cl)
  250. (define member-token
  251.   (lambda (x s)
  252.     ;finds tail of list s starting with token x
  253.     (ormapcdr (lambda (s_i..) (if (token=? (car s_i..) x) s_i.. #f)) 
  254.       s)))
  255.  
  256. '(enable cl)
  257. (define remove-token!
  258.   (lambda (x s)
  259.     (delete x s :test token=?)))
  260.  
  261. '(disable cl)
  262. (define remove-token!
  263.   (lambda (x s)
  264.     ;removes token x destructively from token-list s
  265.     (rem! (lambda (s_i) (token=? s_i x)) s)))
  266.